package NaturalDateGuesser;

use warnings;
use strict;
use Date::Simple qw/today ymd/;

=head1 NAME

NaturalDateGuesser - A natural date parser

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

my @relative_days = qw/Today Yesterday Tomorrow/;
my @days_of_week = qw/Sunday Monday Tuesday Wednesday 
					Thursday Friday Saturday/;

my @months = qw/January February March April May June July 
				August September October November December/;

my @decorators = qw/th rd st/;
my @modifiers = qw/Next Last In/;
my @units = qw/Days Weeks/; # Months Years 

my @all_keywords = (\@days_of_week, \@months, \@decorators, 
					\@modifiers, \@relative_days, \@units );

=head1 SYNOPSIS

This module tries to grok a date.  You would be much better
using Date::Manip.

    use NaturalDateGuesser;

    my $dparser = NaturalDateGuesser->new();
    my $date = $dparser->parseDate("Today");
    ...

=head1 FUNCTIONS

=head2 new

=cut

sub new {
	my ($class) = @_;

	my $self = {};
	bless $self, $class;

	return $self;
}

=head2 parseDate

The function that makes a best guess of the string and returns 
a Date::Simple object.

=cut

sub parseDate {
	my ($self, $string) = @_;

	my $date;
	# rip the string into chunks and then try to 
	# to figure out the date
	my $chunks = $self->_getChunks($string);

	# see if we can distinguish a month, year and date
	# see if we have some relational stuff
	my ($year, $month, $day_of_week, $modifier, 
		$rel_date, $units);
	my @numbers;
	foreach my $chunk (@$chunks)
	{
		if($chunk->{day_of_week})
		{
			$day_of_week = $chunk->{value};
		} elsif($chunk->{relative_day})
		{
			$rel_date = $chunk->{value};
		} elsif($chunk->{unit})
		{
			$units = $chunk->{value};
		} elsif($chunk->{month})
		{
			$month = $chunk->{value};
			my $pos = 0;
			while($months[$pos] ne $month)
			{
				$pos++;
			}
			$month = $pos + 1;
		} elsif($chunk->{year})
		{
			$year = $chunk->{data};
			# this is kinda nasty but
			# it allows us to know where
			# the year appears in the greater
			# scheme of things
			push @numbers, -1;
		} elsif($chunk->{number})
		{
			push @numbers, $chunk->{data};
		} elsif($chunk->{modifier})
		{
			$modifier = $chunk->{value};
		}
	}

	if($year && $month && @numbers)
	{
		my $pos;
		for(my $i = 0; $i < @numbers; $i++)
		{
			if($numbers[$i] > -1)
			{
				$pos = $i;
				last;
			}
		}
		$date = ymd($year, $month, $numbers[$pos]);
	}
	else
	{
		if(@numbers == 3)
		{
			if($numbers[0] == -1) {
				# assume yyyy mm dd format
				$date = ymd($year, $numbers[1], $numbers[2]);
			} else
			{
				# assume dd mm yyyy format
				if($numbers[2] > 0)
				{
					$year = $numbers[2];
					# FIXME: this is really arbitrary,
					# are there any standard conventions?
					# either way, the moral is, use 4 digits!
					# perhaps I should add this as a configuration option?
					if($year < 100 && $year > 38)
					{
						$year += 1900;
					} elsif($year <= 38)
					{
						$year += 2000;
					}
				}
				if($numbers[1] > 12) {
					# guess it must be mm dd yyyy
					$date = ymd($year, $numbers[0], $numbers[1]);
				} else
				{
					$date = ymd($year, $numbers[1], $numbers[0]);
				}
			}
		}
	}

	if(!$date)
	{
		my $today = $self->{today};
		if(!$today)
		{
			$today = today();
		}
		# quite possibly relational
		# lets see if we can figure it out.
		if($rel_date)
		{
			if($rel_date eq "Today")
			{
				$date = $today;
			} elsif($rel_date eq "Tomorrow")
			{
				$date = $today + 1;
			} elsif($rel_date eq "Yesterday")
			{
				$date = $today - 1;
			}
		} elsif($modifier || $day_of_week)
		{
			if($day_of_week)
			{
				my $day_num = dow_to_num($day_of_week);
				my $curr_day = $today->day_of_week;
				my $difference;
				# next is implied, last will modify
				if($modifier && $modifier eq "Last")
				{
					$difference = $day_num - $curr_day;
					if($difference >= 0)
					{
						$difference -= 7;
					}
				} else
				{
					$difference = $day_num - $curr_day;
					if($difference < 0)
					{
						$difference += 7;
					}
					if($modifier && $modifier eq "Next" && $difference == 0)
					{
						$difference += 7;
					}
				}
				$date = $today + $difference;
			} elsif($modifier eq "In" && $units && @numbers)
			{
				# expect something like In x days
				my $modifier;
				if($units eq "Days")
				{
					$modifier = $numbers[0];
				} elsif($units eq "Weeks")
				{
					$modifier = $numbers[0] * 7;
				} elsif($units eq "Months")
				{
				} elsif($units eq "Years")
				{
				}
				$date = $today + $modifier;
			}
			elsif($units && $modifier)
			{
				if($modifier eq "Next" && $units eq "Weeks")
				{
					$date = $today + 7;
				}
				elsif($modifier eq "Last" && $units eq "Weeks")
				{
					$date = $today - 7;
				}
			}
		} else
		{
			if($month && @numbers == 1 && $numbers[0] > 0)
			{
				# they must have just specified
				# something like 23rd June
				$date = ymd($today->year, $month, $numbers[0]);
			} 
		}
	}

	return $date;
}

sub dow_to_num
{
	my ($day) = @_;
	my $pos;
	for(my $i = 0; $i < @days_of_week; $i++)
	{
		if($days_of_week[$i] eq $day)
		{
			$pos = $i;
			last;
		}
	}
	return $pos;
}
# turn it into chunks and do some analysis
# this might be a smidge more than lexxing but
# I'm not sure, let's see how it turns out
sub _getChunks
{
	my ($self, $string) = @_;

	my @characters = split //, $string;
	my @chunks = ();
	my $chunk = {};
	while(@characters)
	{
		my $char = shift @characters;
		if($char =~ /\d/)
		{
			if($chunk->{number})
			{
				$chunk->{data} .= $char;
			} else 
			{
				if($chunk->{data})
				{
					# new chunk
					$self->_completeProcessing($chunk);
					push @chunks, $chunk;
					$chunk = {};
				} 
				$chunk->{number} = 1;
				$chunk->{data} = $char;
			}
		} elsif($char =~ /\w/)
		{
			if($chunk->{word})
			{
				$chunk->{data} .= $char;
			} else
			{
				if($chunk->{data})
				{
					# new chunk
					$self->_completeProcessing($chunk);
					push @chunks, $chunk;
					$chunk = {};
				}
				$chunk->{word} = 1;
				$chunk->{data} = $char;
			}
			if($self->_isCompleteKeyWord($chunk))
			{
				$self->_completeProcessing($chunk);
				push @chunks, $chunk;
				$chunk = {};
			}
		} else
		{
			if($chunk->{data})
			{
				# new chunk
				$self->_completeProcessing($chunk);
				push @chunks, $chunk;
				$chunk = {};
			}
		}
	}
	if($chunk->{data})
	{
		$self->_completeProcessing($chunk);
		push @chunks, $chunk;
	}

	return \@chunks;
}

# see if it's a complete keyword so that we know
# leave it there.
sub _isCompleteKeyWord
{
	my ($self, $token) = @_;
	# only return true if it's the full name
	my $results;

	foreach my $array (@all_keywords)
	{
		$results = grep { uc $_ eq uc $token->{data} } @$array;
		last if $results;
	}
	# this is really inefficient, I'd be better
	# removing the ambigious ones from the list
	# in the first place, or at least calculating
	# the list just once
	my @dow = grep /^\Q$token->{data}/i, @days_of_week;
	my @mon = grep /^\Q$token->{data}/i, @months;
	my @dec = grep /^\Q$token->{data}/i, @decorators;
	my @mod = grep /^\Q$token->{data}/i, @modifiers;
	my @red = grep /^\Q$token->{data}/i, @relative_days;
	my @uni = grep /^\Q$token->{data}/i, @units;
	$results = $results && (@dow + @mon + @dec + @mod + @red + @uni == 1);
	return $results;
}

# mark it up
sub _completeProcessing
{
	# mark the token with the complete info
	my ($self, $token) = @_;

	if($token->{number} && $token->{data} =~ /^\d\d\d\d$/)
	{
		$token->{year} = 1;
	}
	return if(!$token->{word});

	my @dow = grep /^\Q$token->{data}/i, @days_of_week;
	my @mon = grep /^\Q$token->{data}/i, @months;
	my @dec = grep /^\Q$token->{data}/i, @decorators;
	my @mod = grep /^\Q$token->{data}/i, @modifiers;
	my @red = grep /^\Q$token->{data}/i, @relative_days;
	my @uni = grep /^\Q$token->{data}/i, @units;
	# kludge to prevent the ambiguity of th from
	# messing things up
	if(@dec == 1)
	{
		$token->{value} = $dec[0];
		$token->{decoration} = 1;
	} elsif(@dow == 1)
	{
		$token->{value} = $dow[0];
		$token->{day_of_week} = 1;
	} elsif(@mon + @mod + @red + @uni == 1)
	{
		# the search was not ambiguous
		if(@mon)
		{
			$token->{value} = $mon[0];
			$token->{month} = 1;
		} elsif(@mod)
		{
			$token->{value} = $mod[0];
			$token->{modifier} = 1;
		} elsif(@red)
		{
			$token->{value} = $red[0];
			$token->{relative_day} = 1;
		} elsif(@uni)
		{
			$token->{value} = $uni[0];
			$token->{unit} = 1;
		}
	}
}

=head2 setToday
Set the 'Today' date so that the relational dates will 
be calculated from it.

=cut

sub setToday {
	my ($self, $today) = @_;

	$self->{today} = $today;
}

=head1 AUTHOR

Colin Newell, C<< <colin.newell at gmail.com> >>

=head1 BUGS

Please report any bugs or feature requests to
C<colin.newell at gmail.com> or at the web interface
L<http://code.google.com/p/perl-dumb-dateparser/>

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc NaturalDateGuesser

You can also look for information at:

=over 4

=item * Google code

L<http://code.google.com/p/perl-dumb-dateparser/>

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2006 Colin Newell, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of NaturalDateGuesser
